home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / as.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  10.8 KB  |  293 lines
  1. (herald (assembler as t 37)
  2.         (env t (assembler ib)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Random parameters which must be set by the machine description.
  28.                                                                
  29. (define-structure-type machine
  30.   template-emitter ; For EMIT-TEMPLATE - where does this belong? - routine
  31.   cond-branch      ; For the branchifier (change branches to jumps and fall throughs)
  32.   uncond-branch    ;   FG generators for [un]conditional branches
  33.   clump-size       ; 8 for Vax, 16 for 68000
  34.   maximum-clumps   ; 4 for vax  5 or 7 for 68000, max number of pending clumps.
  35.   clump-writer     ; routine to write a clump, see BITS
  36.  
  37.   lap-env          ; For lap processor, table mapping mnemonics to FG routines
  38.   pseudo-ops       ; ... alist of procedures called while processing lap
  39.   pseudo-operands  ; ... ...
  40.   )             
  41.                              
  42.  
  43. ;;; used by emit-template and who else?
  44. (lset *current-machine* (undefined-value '*current-machine*))
  45.  
  46. ;;; Maximally crufty interface.
  47.                                        
  48. (lset *current-ib* nil)
  49. (lset *current-assembly-labels* nil)
  50.                                 
  51. ;;; Optionally retain as data structures for post-mortem
  52.  
  53. (lset *assembler-retains-pointers?* nil)
  54. (lset *current-ib-vector* nil)  
  55. (lset *current-bits* nil)       
  56.  
  57. ;;; The interface maintains a list of IBs generated, a table relating
  58. ;;; code nodes to IBs, and a "current IB."  Emitters side effect the 
  59. ;;; current IB.  Delayed comments are implemented at this level.
  60.  
  61. (define (assemble-init c)
  62.   (bind ((*current-ib* nil)
  63.          (*delayed-comments* '())
  64.          (*current-assembly-labels* 
  65.           (make-labels-table '*current-assembly-labels*)))
  66.     (cond (*assembler-retains-pointers?*
  67.            (set *sdfs* nil)
  68.            (set *current-ib-vector* nil)
  69.            (set *current-bits* nil)
  70.            (c))
  71.           (else
  72.            (bind ((*sdfs* nil)
  73.                   (*current-ib-vector* nil)
  74.                   (*current-bits* nil))
  75.              (c))))))
  76.  
  77. (define (as-debug)
  78.   (set *assembly-comments?* t)
  79.   (set *assembler-retains-pointers?* t))
  80.  
  81. (define (as-undebug)
  82.   (set *sdfs* nil)
  83.   (set *current-ib-vector* nil)
  84.   (set *current-bits* nil)
  85.   (set *assembly-comments?* nil)
  86.   (set *assembler-retains-pointers?* nil))
  87.  
  88. (define (assemble) 
  89.    (let ((bv (bits-bv (as (reverse (table-entry *current-assembly-labels* '&&all&&))
  90.                           *current-machine*))))
  91.       bv))
  92.                                                          
  93. ;;; Comments.
  94.  
  95. ;;; Delayed comments are tacked on the next thing emitted.
  96.  
  97. (lset *delayed-comments* '())
  98.  
  99. (define (delayed-comment the-comment)
  100.    (push *delayed-comments* the-comment))
  101.  
  102. (define (emit-delayed-comments ib)
  103.     (emit-comments-to-ib *current-ib* *delayed-comments*)
  104.     (set *delayed-comments* '()))
  105.  
  106. (define-integrable (flush-delayed-comments)
  107.     (if (not (null? *delayed-comments*)) 
  108.         (emit-delayed-comments *current-ib*)))
  109.  
  110. ;;; Comment is tacked on to previously emitted instruction.
  111.  
  112. (define (comment-now the-comment)
  113.    (emit-comment-to-ib *current-ib* the-comment))
  114.  
  115. (define emit-comment delayed-comment)
  116.  
  117. ;;; 
  118.  
  119. (define (emit-jump symbolic-jop 1tag 0tag)
  120.   (let ((jop (xcond ((fixnum? symbolic-jop) symbolic-jop)
  121.                     ((eq? symbolic-jop 'jneq) jump-op/jn=)
  122.                     ((eq? symbolic-jop 'jgeq) jump-op/j>=)
  123.                     ((eq? symbolic-jop 'jgtr) jump-op/j>)
  124.                     ((eq? symbolic-jop 'jeql) jump-op/j=)
  125.                     ((eq? symbolic-jop 'jmp)  jump-op/jabs)
  126.                     )))
  127.      (emit-jump-to-ib *current-ib* jop 1tag 0tag)
  128.      (flush-delayed-comments)))
  129.  
  130. ;;; Try to force the 1tag block to follow the current block
  131.  
  132. (define (emit-avoid-jump symbolic-jop 1tag 0tag)
  133.   (emit-jump symbolic-jop 1tag 0tag)
  134.   (maybe-set-ib-follower *current-ib* (xcurrent-label 1tag)) ; xcu... is wrong
  135.   )
  136.  
  137. (define (emit-template code-node handler-node)
  138.   (let ((cib (data-current-label code-node))
  139.         (hib (data-current-label handler-node)))
  140.     (let ((tib (data-current-label cib)))
  141.       ((machine-template-emitter *current-machine*) code-node cib hib tib)
  142.       (set *current-ib* cib)
  143.       (flush-delayed-comments)
  144.       )))
  145.  
  146. (define (emit-tag code-node)
  147.   (let ((ib (xcurrent-label code-node)))
  148.     (set *current-ib* ib)
  149.     (cond ((and *as-list-comments?* (node? code-node))
  150.            (set (ib-name ib)
  151.                 (xcond ((lambda-node? code-node)
  152.                         (lambda-name code-node))
  153.                        ((leaf-node? code-node)
  154.                         (variable-unique-name code-node))))))
  155.     ))
  156.  
  157. (define (code-vector-offset label)
  158.     (fixnum-ashr (code-offset *current-assembly-labels* label) 3))
  159.  
  160. ;;; ---- The clean assembler interface routines.
  161.                                                               
  162. (define (emit-to-ib ib fg)
  163.   (context-fg fg)
  164.   (compress-fg fg)
  165.   (push (ib-instructions ib) fg))
  166.  
  167. (define (emit-jump-to-ib ib jop 1tag 0tag)
  168.     (set (ib-jump-op ib) jop)
  169.     (if 1tag (set (ib-1tag ib) (jump-current-label 1tag ib)))
  170.     (if 0tag (set (ib-0tag ib) (jump-current-label 0tag ib)))
  171.     )
  172.  
  173. ;;; Any assembly has an associated table of labels, maintained by the following.
  174. ;;; LABELZ ought to be spelled LABELS. 
  175.  
  176. ;;; A labels table remebers a list of every ib entered.  This
  177. ;;; ought to be a structure.
  178.                                   
  179. (define (make-labels-table id)
  180.   (let ((tab (make-table id)))
  181.     (set (table-entry tab '&&all&&) '())
  182.     tab))
  183.                  
  184. ;;; Return ib associated with the label, make (& return) a new ib if no
  185. ;;;   such label exists.
  186.  
  187. (define (jump-current-label label jumper-ib)
  188.   (let ((target-ib (xcurrent-label label)))
  189.     (push (ib-jumped-to-by target-ib) jumper-ib)
  190.     target-ib))
  191.  
  192. (define (data-current-label label)
  193.   (let ((target-ib (xcurrent-label label)))
  194.     (set (ib-data-label? target-ib) t)
  195.     target-ib))
  196.  
  197. (define (xcurrent-label label)
  198.     (as-label *current-assembly-labels* label))
  199.  
  200. (define (as-label labelz label)
  201.   (cond ((table-entry labelz label)
  202.          => identity)
  203.         (else
  204.          (let ((ib (make-ib)))
  205.            (modify (table-entry labelz '&&all&&) (lambda (x) (cons ib x)))
  206.            (set (table-entry labelz label) ib)
  207.            ib))))
  208.  
  209. ;;; Returns tag that can be used to access emitted data.
  210. ;;; e.g. 
  211. ;;;      (emit-pure-data (vax-d-floating-bits 1.2))
  212. ;;;      (emit-pure-data (apollo-d-ieee-floating-bits 1.2))
  213.  
  214. (define (emit-pure-data data-fg)
  215.     (let ((ib (data-current-label data-fg)))
  216.         (emit-to-ib ib data-fg)
  217.         ib))
  218.         
  219. ;;; Comments are keyed by pairs in the ib-instructions list, so the comment
  220. ;;; is tacked on to the last thing emitted.
  221.  
  222. (define (emit-comment-to-ib ib the-comment)
  223.    (let ((i's (ib-instructions ib)))
  224.      (let ((key (if (null? i's) '() i's)))
  225.        (let ((c's (ib-comments ib)))
  226.           (cond ((and (pair? c's) (pair? (car c's)) (eq? (caar c's) key))
  227.                  (modify (cdr (car c's)) (lambda (l) (cons the-comment l))))
  228.                 (else
  229.                  (set (ib-comments ib) `((,i's ,the-comment) ,@c's))))))))
  230.  
  231. ;;; As above but for a list of comments.  Blah.
  232.  
  233. (define (emit-comments-to-ib ib the-comments)
  234.    (let ((i's (ib-instructions ib)))
  235.      (let ((key (if (null? i's) '() i's)))
  236.        (let ((c's (ib-comments ib)))
  237.           (cond ((and (pair? c's) (pair? (car c's)) (eq? (caar c's) key))
  238.                  (modify (cdr (car c's)) (lambda (l) (append the-comments l))))
  239.                 (else
  240.                  (set (ib-comments ib) `((,i's ,@the-comments) ,@c's))))))))
  241.  
  242. ;;; Given label, return its offset in the code
  243.  
  244. (define (code-offset labelz label)
  245.   (cond ((table-entry labelz label)
  246.          => (lambda (n) 
  247.                (cond ((not (ib? n))
  248.                       (bug "no IB for label ~s in ~s" label labelz))
  249.                      (else              
  250.                       (ib-address n)))))
  251.         (else
  252.          (bug "no label ~s in ~s" label labelz))))
  253.                                           
  254. ;;; Fixup IO to luser.  Assemble a list of IBs into a bytev vector.
  255. ;;; returns a BITS structure.
  256.  
  257. (define (as ibs machine)
  258.   (orbit-debug ";;; (@ ~s) = *CURRENT-ASSEMBLY-LABELS*~%" 
  259.                (object-hash *current-assembly-labels*))
  260.   (let ((ibv (ib-order ibs)))
  261.  
  262.     (set *current-ib-vector* ibv)   ; debugging
  263.     ;; consistency check
  264.     (let ((ibv-length (vector-length ibv)))
  265.        (do ((i 0 (fx+ i 1)))
  266.            ((fx>= i ibv-length) '*)
  267.          (if (or (not (ib? (vref ibv i)))
  268.                  (fxn= i (ib-pos (vref ibv i))))
  269.              (bug "ibs not ordered correctly"))))
  270.  
  271.     (branchify ibv machine)
  272.     (receive (mark-count span-count) 
  273.              (count-spans ibv)
  274.       (receive (min-size sdfs mark-addresses mark-sdf-positions)
  275.                (marker ibv mark-count span-count)
  276.         (let* ((mini-iterations (minimize-displacements sdfs))  ;; nia loses
  277.                (max-adj (fixup-labels ibv sdfs mark-addresses mark-sdf-positions)))
  278.           (receive (b bits-length)
  279.                    (bits ibv (fx+ min-size max-adj) machine)
  280.             (format *noise+terminal* "~g~%"
  281.                    `(as
  282.                      (ib      ,(vector-length ibv))
  283.                      (sdf     ,(vector-length sdfs))
  284.                      (align   ,(count-align-sdfs sdfs))
  285.                      (mark    ,(vector-length mark-addresses))
  286.                      (clean   ,(car mini-iterations))
  287.                      (dirty   ,(cdr mini-iterations))
  288.                      (bytes   ,bits-length)
  289.                      ))
  290.              (set *current-bits* b)
  291.              b))))))
  292.  
  293.